home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / menusAndKeys.tcl < prev    next >
Encoding:
Text File  |  2000-12-14  |  27.8 KB  |  904 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  AlphaTcl - core Tcl engine
  4.  # 
  5.  #  FILE: "menusAndKeys.tcl"
  6.  #                                    created: 12/9/97 {1:43:22 pm} 
  7.  #                                last update: 12/14/2000 {10:17:36 AM} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <vince@santafe.edu>
  10.  #    mail: 317 Paseo de Peralta
  11.  #          Santa Fe, NM 87501, USA
  12.  #     www: <http://www.santafe.edu/~vince/>
  13.  #  
  14.  # Reorganisation carried out by Vince Darley with much help from Tom 
  15.  # Fetherston, Johan Linde and suggestions from the Alpha-D mailing list.  
  16.  # Alpha is shareware; please register with the author using the register 
  17.  # button in the about box.
  18.  #  
  19.  # 
  20.  #  modified by  rev reason
  21.  #  -------- --- --- -----------
  22.  #  27/11/97 FBO x.x make keys::keyboardChanged use one more item in keyboards
  23.  # ###################################################################
  24.  ##
  25.  
  26. namespace eval menu {}
  27. namespace eval keys {}
  28. namespace eval bind {}
  29.  
  30. ## 
  31.  # -------------------------------------------------------------------------
  32.  # 
  33.  # "menu::bind" --
  34.  # 
  35.  #  Convert a preference of type 'binding' or 'menubinding' into a code
  36.  #  to be inserted into a menu.  Menu-bindings are guaranteed to succeed.
  37.  #  If an ordinary binding contains a prefixChar (e.g. you have bound
  38.  #  ctrl-c followed by ctrl-x to something), then this procedure will
  39.  #  return an empty string, since such bindings cannot appear in menus.
  40.  #  Finally if it is a key-binding and it does not contain a modifier
  41.  #  key, and the key is a normal key (not F1-F12 + few others), then
  42.  #  it will appear in the menu, but the menu will not activate with
  43.  #  that key.  On MacOS, menus can only activate with key-presses
  44.  #  which include a modifier.
  45.  #  
  46.  #  Example usage (from the modeSearchPaths package):
  47.  #  
  48.  #     newPref binding openSelection "<O<B/H" searchPaths
  49.  #     newPref binding sourceHeaderToggle "<O/f" searchPaths
  50.  #   menu::addTo fileUtils \
  51.  #        "[menu::bind searchPathsmodeVars(sourceHeaderToggle) -]" \
  52.  #        "[menu::bind searchPathsmodeVars(openSelection) -]"
  53.  #  
  54.  #  You can adjust these bindings in the package preferences dialog,
  55.  #  but changes will not take effect until you restart Alpha.  Note
  56.  #  that if the user selected menu-incompatible bindings, they would
  57.  #  not operate without the addition of some code to Bind them.  One
  58.  #  would need to add this:
  59.  #  
  60.  #   eval Bind \
  61.  #     [keys::toBind $searchPathsmodeVars(sourceHeaderToggle)] \
  62.  #     file::sourceHeaderToggle
  63.  #   
  64.  #  The optional arg is the rest of the menu item or '-' which means
  65.  #  use the variable name (if a var) or array element (if an array).
  66.  #  
  67.  #  If the optional argument is given, and the menu item therefore
  68.  #  contains a '/', it is considered to be two dynamic items, the
  69.  #  second of which requires the option key to be used.
  70.  #  
  71.  #  Similarly '//' means use shift, '///' means shift-option,
  72.  #  For instance 'set v /W<O ; menu::bind v close/closeAll//closeFloat'
  73.  #  would give you the menu-item for 'close' in the file menu. 
  74.  # -------------------------------------------------------------------------
  75.  ##
  76. proc menu::bind {var {item ""}} {
  77.     upvar \#0 $var a
  78.     if {[regexp {«(.*)»} $a]} { set ret "" } else { set ret $a }
  79.     if {$item != ""} {
  80.     if {$item == "-"} {
  81.         regsub -all {([a-zA-Z_:]+\(|\))} $var {} item
  82.     }
  83.     if {[regexp {/} $item]} {
  84.         set item "<S<E<K$item"
  85.         regsub {///} $item " <S<I<U<K" item
  86.         regsub {//} $item " <S<U<K" item
  87.         regsub {/} $item " <S<I<K" item
  88.         regsub -all {<K} $item $ret ret
  89.     } else {
  90.         append ret $item
  91.     }
  92.     }
  93.     return $ret
  94. }
  95.  
  96. # ◊◊◊◊ flags-menus from prefs ◊◊◊◊ #
  97. # The following four procs allow you to create flag menus with ticks
  98. # very simply.  They adhere to the basic idea of the 'newPref' facility.
  99. proc menu::makeFlagDummy {name {type list}} {
  100.     switch -- $type {
  101.     "array" {
  102.         return [list Menu -n $name -p menu::flagProc {}]
  103.     }
  104.     "list" {
  105.         return [list Menu -m -n $name -p menu::flagProc {}]
  106.     }
  107.     }
  108. }
  109.  
  110. proc menu::makeFlagMenu {name {type list} {var ""} {in_array ""} \
  111.   {nonFlagProc ""} {prologue ""} {epilogue ""}} {
  112.     if {$var == ""} { set var $name }
  113.     switch -- $type {
  114.     "array" {
  115.         global $var menu::flagArray allFlags
  116.         set menu::flagArray($name) \
  117.           [list "array" $var "" $nonFlagProc]
  118.         foreach i [lsort [array names $var]] {
  119.         if {[lsearch -exact $allFlags $i] != -1} {
  120.             lappend items [lindex [list "$i" "!•$i"] [set ${var}($i)]]
  121.         }
  122.         }
  123.         if {[info tclversion] >= 8.0} {
  124.         return [list Menu -t checkbutton -n $name -p menu::flagProc $items]
  125.         } else {
  126.         return [list Menu -n $name -p menu::flagProc $items]
  127.         }
  128.     }
  129.     "list" {
  130.         global $var menu::flagArray
  131.         if {[string length $in_array]} {
  132.         set menu::flagArray($name) [list "list" $in_array $var $nonFlagProc]
  133.         global $in_array
  134.         set val [set ${in_array}($var)]
  135.         } else {
  136.         set menu::flagArray($name) \
  137.           [list "list" $var "" $nonFlagProc]
  138.         set val [set $var]
  139.         }
  140.         set i [lsearch -exact [set items [flag::options $var]] $val]
  141.         if {$i != -1} {
  142.         set items [lreplace $items $i $i "!•[lindex $items $i]"]
  143.         }
  144.         if {$prologue != ""} {
  145.         set items [concat $prologue [expr {[llength $items] ? {(-} : ""}] $items]
  146.         } 
  147.         if {$epilogue != ""} {
  148.         set items [concat $items [expr {[llength $items] ? {(-} : ""}] $epilogue]
  149.         }
  150.         if {[info tclversion] >= 8.0} {
  151.         return [list Menu -m -t radiobutton -n $name -p menu::flagProc $items]
  152.         } else {
  153.         return [list Menu -m -n $name -p menu::flagProc $items]
  154.         }
  155.     }
  156.     default {
  157.         error "Other types not yet supported"
  158.     }
  159.     }
  160. }
  161.  
  162. proc menu::stripMetaChars {menuItems} {
  163.     set strippedItems ""
  164.     
  165.     foreach menuItem $menuItems {
  166.     regsub -all {<(B|I|U|O|S|E)} $menuItem "" menuItem
  167.     regsub -all {/.} $menuItem "" menuItem
  168.     regsub -all {!.} $menuItem "" menuItem
  169.     regsub -all {\^.} $menuItem "" menuItem
  170.     regsub -all {…$} $menuItem "" menuItem
  171.     lappend strippedItems $menuItem
  172.     }
  173.     
  174.     return $strippedItems
  175. }
  176.  
  177. proc menu::buildFlagMenu {name args} {
  178.     eval [eval menu::makeFlagMenu [list $name] $args]
  179. }
  180.  
  181. proc menu::flagProc {menu flag} {
  182.     global menu::flagArray flag::procs modifiedArrayElements modifiedVars
  183.     set type [set menu::flagArray($menu)]
  184.     
  185.     set name [lindex $type 1]
  186.     upvar \#0 $name a
  187.     switch -- [lindex $type 0] {
  188.     "array" {
  189.         if {[lsearch -exact [array names a] $flag] == -1} {
  190.         [lindex $type 3] $menu $flag 
  191.         } else {
  192.         set a($flag) [expr {1 - $a($flag)}]
  193.         if {[info exists flag::procs($flag)]} {
  194.             [set flag::procs($flag)] $flag
  195.         }
  196.         message "$menu item '$flag' set to $a($flag)"
  197.         markMenuItem $menu $flag $a($flag)
  198.         lunion modifiedArrayElements [list $flag $name]
  199.         }
  200.     }
  201.     "list" {
  202.         # array entries are indexed by the '2' element.
  203.         if {[set var [lindex $type 2]] == ""} { set var $name }
  204.         
  205.         set idx [lsearch -exact [flag::options $var] $flag]
  206.         # Workaround removal of ellipsis from menu items.
  207.         if {$idx == -1} {
  208.         set idx [lsearch -exact [flag::options $var] "${flag}…"]
  209.         if {$idx != -1} {
  210.             append flag "…"
  211.         }
  212.         }
  213.         if {[string length [lindex $type 3]] && ($idx == -1)} {
  214.         [lindex $type 3] $menu $flag 
  215.         } else {
  216.         if {[set b [lindex $type 2]] == ""} {
  217.             markMenuItem $menu $a off
  218.             set a $flag
  219.             lunion modifiedVars [lindex $type 1]
  220.             message "[lindex $type 1] set to $flag"
  221.         } else {
  222.             markMenuItem $menu $a($b) off
  223.             set a($b) $flag
  224.             lunion modifiedArrayElements [list [lindex $type 2] [lindex $type 1]]
  225.             message "$menu set to $flag"
  226.         }
  227.         markMenuItem $menu $flag on
  228.         if {[info exists flag::procs([lindex $type 1])]} {
  229.             [set flag::procs([lindex $type 1])] $flag
  230.         }
  231.         }
  232.     }
  233.     }
  234. }
  235.  
  236. # ◊◊◊◊ Bindings ◊◊◊◊ #
  237.  
  238. proc menu::bindingsFromArray {arr {include_empty 0}} {
  239.     upvar $arr ar
  240.     set r {}
  241.     foreach a [array names ar] {
  242.     if {[set b $ar($a)] != "" || $include_empty} {
  243.         lappend r "$b$a"
  244.     }
  245.     }
  246.     return $r
  247. }
  248.  
  249. proc bind::fromArray {arr bindarr {unbind 0} {mode {}}} {
  250.     upvar $arr ar
  251.     upvar $bindarr br
  252.     set r {}
  253.     if {$unbind} {
  254.     set bindcmd "unBind"
  255.     } else {
  256.     set bindcmd "Bind"
  257.     }
  258.     foreach a [array names ar] {
  259.     if {[set b $ar($a)] != ""} {
  260.         if {[info exists br($a)]} {
  261.         catch {eval $bindcmd [keys::toBind $b] [list $br($a)] $mode}
  262.         } else {
  263.         beep; message "Bad bind-array entry '$a'"
  264.         }
  265.     }
  266.     }
  267. }
  268.  
  269. ### 
  270.  # -------------------------------------------------------------------------
  271.  # 
  272.  # "keys::verboseKey" --
  273.  # 
  274.  #  Turn a string containing a menu key-code '/x' into a verbose description
  275.  #  of that key.  The optional parameter declares a variable whose value
  276.  #  will be set if the key is a normal key.
  277.  # -------------------------------------------------------------------------
  278.  ##
  279. proc keys::verboseKey {kstr {normal {}}} {
  280.     if {$normal != ""} {upvar $normal n ; set n 0}
  281.     if {![regexp {/(Kpad)(.)} $kstr "" key pad] && ![regexp {/(.)} $kstr "" key]} { return "" }
  282.     switch -regexp -- $key {
  283.     {Kpad} {return "Key pad $pad"}
  284.     {[a-z]} {
  285.         global keys::func
  286.         return [lindex ${keys::func} [expr {[text::Ascii $key] - 97}]]
  287.     }
  288.     "" {
  289.         return "Left"
  290.     }
  291.     "" {
  292.         return "Right"
  293.     }
  294.     "\x10" {
  295.         return "Up"
  296.     }
  297.     "" {
  298.         return "Down"
  299.     }
  300.     " " {
  301.         return "Space"
  302.     }
  303.     default {
  304.         set n 1
  305.         return $key
  306.     }
  307.     }
  308. }
  309.  
  310. set keys::func {Enter Return Tab "Num Lock" F1 F2 F3 F4 F5 F6 F7 F8 F9 F10 \
  311.   F11 F12 F13 F14 F15 Help Delete "Fwd Del" Home End "Page Up" "Page Down"}
  312.  
  313. set keys::ascii {0x03 0x0d 0x09 0 0 0 0 0 0 0 0 0 0 0 \
  314.   0 0 0 0 0 0 0x08 0 0 0 0 0}
  315.  
  316. set keys::bind {Enter 0x24 0x30 Clear F1 F2 F3 F4 F5 F6 F7 F8 F9 F10 \
  317.   F11 F12 F13 F14 F15 Help 0x33 Del Home End Pgup Pgdn}
  318.  
  319. ## 
  320.  # -------------------------------------------------------------------------
  321.  # 
  322.  # "keys::toBind" --
  323.  # 
  324.  #  Turn a menu key-modifier sequence into something suitable for
  325.  #  a 'bind' statement.  Copes with function keys and arrow keys.
  326.  #  
  327.  #  Use a couple of strings to perform shift-mappings, so that although
  328.  #  the binding says it's bound to 'shift-1', say, in fact it must be
  329.  #  bound to '!' (or shift-'!' which are equivalent), since '!' is a 
  330.  #  shifted '1'.
  331.  #  
  332.  #  You can use 'addcode' to add modifiers.  Mostly useful for pairs
  333.  #  of bindings stored in a single pref in which one is an option/shift
  334.  #  modified version of the other.
  335.  # -------------------------------------------------------------------------
  336.  ##
  337. proc keys::toBind {kstr {addcode {}}} {
  338.     if {![regexp {/(Kpad.)$} $kstr "" key] && ![regexp {/(.)} $kstr "" key]} { return "" }
  339.     if {![string match Kpad* $key] && [regexp {[a-z]} $key]} {
  340.     global keys::bind
  341.     set key [lindex ${keys::bind} [expr {[text::Ascii $key] - 97}]]
  342.     } elseif {[set i [lsearch -exact {" " "" "" "\x10" ""} $key]] != -1} {
  343.     set key [lindex {0x31 0x7b 0x7c 0x7e 0x7d} $i]
  344.     } elseif {![string match Kpad* $key]} {
  345.     set key [string tolower $key]
  346.     }
  347.     if {[string length $key] == 1} {
  348.     global keys::mapShiftBindFrom keys::mapShiftBindTo
  349.     if {[regexp {[a-z]} $key] || ![regexp {^<U/} $kstr]} {
  350.         set key '${key}' 
  351.     } elseif {[set i [string first $key ${keys::mapShiftBindFrom}]] != -1} {
  352.         set key '[string index ${keys::mapShiftBindTo} $i]'
  353.     } else {
  354.         #alertnote "Weird key: $kstr, please tell Vince."
  355.         # Note from Vince: I think it's ok just to assume we can
  356.         # bind to the key like this, but it's possible there are
  357.         # some problems on international keyboards.  With a U.S.
  358.         # keyboard we should NEVER get here.
  359.         set key '${key}'
  360.     }
  361.     }
  362.     global keys::international
  363.     if {[info exists keys::international($key)]} {
  364.     set key [set keys::international($key)]
  365.     }
  366.     if {[set a [keys::modifiersTo $kstr$addcode bind]] != ""} {
  367.     return [list $key $a]
  368.     } else {
  369.     return [list $key]
  370.     }
  371. }
  372.  
  373. ## 
  374.  # -------------------------------------------------------------------------
  375.  # 
  376.  # "keys::keyboardChanged" --
  377.  # 
  378.  #  When we change the value of 'keyboards' in the international prefs,
  379.  #  this is called, with the parameter 'keyboards'.
  380.  #  
  381.  #  It is also called at startup, with no parameter.
  382.  #  
  383.  #  Frédéric Boulanger <Frederic.Boulanger@supelec.fr> Nov 27 1997
  384.  #    Added one item to the keyboards items: a list of characters followed
  385.  #    by corresponding key codes.
  386.  #    keys::keyboardChanged now looks for these items and sets 
  387.  #    keys::international to the corresponding key code for each character
  388.  #    in the first list. This is so keys::toBind returns a key code 
  389.  #    instead of a character, which makes Bind only Bind the given character
  390.  #    and leave the shifted char unbound. The problem arose on a french 
  391.  #    keyboard where '{' is '(' <o> and '[' is '(' <os> . Binding '(' <o>
  392.  #    to bind::LeftBrace also binds '(' <os> to bind::LeftBrace, so it was
  393.  #    impossible to type a '['. To avoid this problem, we have to Bind
  394.  #    0x17 <o> to bind::LeftBrace, where 0x17 is the key code for '(' on a
  395.  #    french keyboard.
  396.  #    For other keyboards, I don't know the key codes, so if you have the
  397.  #    same problem with bindings, you may change the definition of your 
  398.  #    keyboard in alphaDefinitions.tcl to solve it.
  399.  # -------------------------------------------------------------------------
  400.  ##
  401. proc keys::keyboardChanged {{flag "startup"}} {
  402.     global keyboards keyboard keys::mapShiftBindFrom keys::mapShiftBindTo \
  403.       modifiedVars oldkeyboard bind::LeftBrace bind::RightBrace keys::international
  404.     if {$oldkeyboard != ""} {
  405.     catch "unBind [keys::toBind ${bind::LeftBrace}] bind::LeftBrace"
  406.     catch "unBind [keys::toBind ${bind::RightBrace}] bind::RightBrace"
  407.     set i 0
  408.     foreach k [lindex $keyboards($oldkeyboard) 4] {
  409.         if {[incr i] % 2} {catch {unset keys::international($k)}}
  410.     }
  411.     catch {unset keys::international}
  412.     hook::callAll removekeyboard $oldkeyboard
  413.     }
  414.     # set new values
  415.     set keys::mapShiftBindFrom [lindex $keyboards($keyboard) 0]
  416.     set keys::mapShiftBindTo [lindex $keyboards($keyboard) 1]
  417.     set bind::LeftBrace [lindex $keyboards($keyboard) 2]
  418.     set bind::RightBrace [lindex $keyboards($keyboard) 3]
  419.     if {[llength $keyboards($keyboard)] >= 5} {
  420.     array set keys::international [lindex $keyboards($keyboard) 4]
  421.     }
  422.     # Bind
  423.     catch "Bind [keys::toBind ${bind::LeftBrace}] bind::LeftBrace"
  424.     catch "Bind [keys::toBind ${bind::RightBrace}] bind::RightBrace"
  425.     # Call anything that's been registered to the new keyboard
  426.     # (Usually a proc to change some menu-bindings).  Use:   
  427.     #   hook::register keyboard "Swiss French" my-proc
  428.     hook::callAll keyboard $keyboard
  429.     if {$oldkeyboard != ""} {
  430.     lappend modifiedVars keyboard
  431.     alertnote "Changing the keyboard may require you to restart\
  432.       Alpha for the bindings to be set correctly."
  433.     }
  434.     set oldkeyboard $keyboard
  435. }
  436.  
  437. proc bind::fromPref {f {un ""}} {
  438.     global flag::binding
  439.     if {[info exists flag::binding($f)]} {
  440.     set m [lindex [set flag::binding($f)] 0]
  441.     if {[set proc [lindex [set flag::binding($f)] 1]] == 1} {
  442.         set proc $f
  443.     }
  444.     namespace eval ::alpha [list catch "${un}Bind [keys::toBind $old] [list $proc] $m"]
  445.     }
  446. }
  447.  
  448.  
  449. ## 
  450.  # -------------------------------------------------------------------------
  451.  # 
  452.  # "keys::modifiersTo" --
  453.  # 
  454.  #  Turn a menu-modifier sequence into something else.  Options are 
  455.  #  'verbose' (a textual description), 'bind' (a binding code-sequence),
  456.  #  and 'menu' which just returns what was given.
  457.  # -------------------------------------------------------------------------
  458.  ##
  459. proc keys::modifiersTo {key type} {
  460.     global alpha::modifier_keys
  461.     set key1 {}
  462.     switch -- $type {
  463.     "verbose" {
  464.         if {[regexp {«(.)»} $key d pref]} {
  465.         if {$pref == "e"} {
  466.             append key1 "escape "
  467.         } else {
  468.             append key1 "ctrl-$pref "
  469.         }
  470.         }
  471.         if {[regexp {<U} $key]} {append key1 "shift-"}
  472.         if {[regexp {<B} $key]} {append key1 "ctrl-"}
  473.         if {[regexp {<I} $key]} {
  474.         append key1 "[lindex ${alpha::modifier_keys} 3]-"
  475.         }
  476.         if {[regexp {<O} $key]} {
  477.         append key1 "[lindex ${alpha::modifier_keys} 1]-"
  478.         }
  479.         return $key1
  480.     }
  481.     "tksym" {
  482.         if {[regexp {«(.)»} $key d pref]} {
  483.         if {$pref == "e"} {
  484.             append key1 "Escape "
  485.         } else {
  486.             append key1 "Control-$pref "
  487.         }
  488.         }
  489.         if {[regexp {<U} $key]} {append key1 "Shift-"}
  490.         if {[regexp {<B} $key]} {append key1 "Control-"}
  491.         if {[regexp {<I} $key]} {
  492.         append key1 "[lindex ${alpha::modifier_keys} 2]-"
  493.         } 
  494.         if {[regexp {<O} $key]} {
  495.         append key1 "[lindex ${alpha::modifier_keys} 0]-"
  496.         }
  497.         return $key1
  498.     }
  499.     "bind" {
  500.         if {[regexp {<U} $key]} {append key1 "s"}
  501.         if {[regexp {<B} $key]} {append key1 "z"}
  502.         if {[regexp {<I} $key]} {append key1 "o"}
  503.         if {[regexp {<O} $key]} {append key1 "c"}
  504.         if {[regexp {«(.)»} $key d pref]} {
  505.         append key1 $pref
  506.         }
  507.         if {$key1 != ""} {
  508.         return "<${key1}>"
  509.         } else {
  510.         return ""
  511.         }
  512.     }
  513.     "menu" {
  514.         if {[regexp {«(.)»} $key d pref]} {
  515.         return ""
  516.         } else {
  517.         return $key
  518.         }
  519.     }
  520.     }
  521. }
  522.  
  523. ## 
  524.  # -------------------------------------------------------------------------
  525.  # 
  526.  # "keys::bindToMenu" --
  527.  # 
  528.  #  Doesn't yet cope with function keys etc, nor 0x31 type bindings,
  529.  #  nor prefixChars (which can't go in a menu anyway).
  530.  # -------------------------------------------------------------------------
  531.  ##
  532. proc keys::bindToMenu {i} {
  533.     regexp {'(.)'[ \t]*<([^>]+)>} $i d key mods
  534.     set key "/[string toupper $key]"
  535.     if {[regexp {s} $mods]} {append key "<U"}
  536.     if {[regexp {z} $mods]} {append key "<B"}
  537.     if {[regexp {o} $mods]} {append key "<I"}
  538.     if {[regexp {c} $mods]} {append key "<O"}
  539.     return $key
  540. }
  541.     
  542. ## 
  543.  # -------------------------------------------------------------------------
  544.  # 
  545.  # "keys::findPrefixChars" --
  546.  # 
  547.  #  This proc is rather slow, since it has to scan an enormous list of
  548.  #  bindings.  However since it is only used from a few dialogs,
  549.  #  that doesn't matter too much (i.e. it is quick enough on my machine).
  550.  # -------------------------------------------------------------------------
  551.  ##
  552. proc keys::findPrefixChars {} {
  553.     global alpha::platform
  554.     set menu ""
  555.     foreach i [keys::findBindingsTo "prefixChar.*"] {
  556.     if {${alpha::platform} == "alpha"} {
  557.         if {![regexp {'(.)'[ \t]*<z>} $i "" key]} {
  558.         beep; message "A bad prefix char has been defined: Bind $i prefixChar, this will not work."
  559.         } else {
  560.         lappend menu [string toupper $key]
  561.         }
  562.     } else {
  563.         if {[regexp -- "-(\[a-z\])>" $i "" key]} {
  564.         lappend menu [string toupper $key]
  565.         }
  566.     }
  567.     }
  568.     return $menu
  569. }
  570.  
  571. proc keys::findBindingsTo {to {mode ""} {lines 0}} {
  572.     global alpha::platform
  573.     set pref {}
  574.     if {${alpha::platform} == "alpha"} {
  575.     if {$mode == "*"} { set mode "(\\w+)?" }
  576.     set t [bindingList]
  577.     while {[regexp -indices "\[\r\n\]Bind(\[^\r\n\]+) $to *${mode} *\[\r\n\]" $t d idx]} {
  578.         if {$lines} {
  579.         lappend pref [string trim [eval string range [list $t] $d]]
  580.         } else {
  581.         lappend pref [string trim [eval string range [list $t] $idx]]
  582.         }
  583.         set t [string range $t [lindex $idx 1] end]
  584.     }
  585.     } else {
  586.     foreach b [split [bindingList] "\r\n"] {
  587.         if {$mode == ""} {
  588.         if {[lindex $b 1] != "Alpha"} {continue}
  589.         } elseif {$mode != "*"} {
  590.         if {[lindex $b 1] != "${mode}AlphaStyle"} {continue}
  591.         }
  592.         set _to [lindex $b 3]
  593.         set _to [string range $_to 0 [expr {[string length $_to]-8}]]
  594.         if {![regexp -- $to [string trim $_to]]} {continue}
  595.         if {$lines} {
  596.         lappend pref $b
  597.         } else {
  598.         lappend pref [lindex $b 2]
  599.         }
  600.     }
  601.     }
  602.     return $pref
  603. }
  604.  
  605. proc keys::findBindingsOf {of {mode ""}} {
  606.     if {$mode == "*"} { set mode "(\\w+)?" }
  607.     set t [bindingList]
  608.     set pref ""
  609.     while {[regexp -indices "\[\r\n\]Bind[quote::WhitespaceReg " ${of} "](\[\\w:\]+) *${mode} *\[\r\n\]" $t l idx]} {
  610.     lappend pref [string trim [eval string range [list $t] $l]]
  611.     set t [string range $t [lindex $idx 1] end]
  612.     }
  613.     return $pref
  614. }
  615.  
  616. proc keys::unsetBinding {v {mode ""}} {
  617.     foreach i [keys::findBindingsOf $v $mode] {
  618.     regsub {' '} $i {0x31} i
  619.     eval "un${i}"
  620.     }
  621. }
  622.  
  623. proc keys::bindPackage {pkg} {
  624.     global ${pkg}modeVars flag::type flag::binding
  625.     foreach v [array names ${pkg}modeVars] {
  626.     if {[info exists flag::type($v)] && [set flag::type($v)] == "binding"} {
  627.         if {[info exists flag::binding($v)]} {
  628.         set m [lindex [set flag::binding($v)] 0]
  629.         if {[set proc [lindex [set flag::binding($v)] 1]] == 1} {
  630.             set proc $v
  631.         }
  632.         namespace eval ::alpha [list catch "Bind [keys::toBind [set ${pkg}modeVars($v)]] [list $proc] $m"]
  633.         }
  634.     }
  635.     }
  636. }
  637.  
  638. # ◊◊◊◊ Key presses ◊◊◊◊ #
  639. namespace eval key {}
  640.  
  641. proc key::optionPressed {{m ""}} {
  642.     if {$m == ""} {set m [getModifiers]}
  643.     return [expr {$m & 72}]
  644. }
  645. proc key::shiftPressed {{m ""}} {
  646.     if {$m == ""} {set m [getModifiers]}
  647.     return [expr {$m & 34}]
  648. }
  649. proc key::controlPressed {{m ""}} {
  650.     if {$m == ""} {set m [getModifiers]}
  651.     return [expr {$m & 144}]
  652. }
  653. proc key::cmdPressed {{m ""}} {
  654.     if {$m == ""} {set m [getModifiers]}
  655.     return [expr {$m & 1}]
  656. }
  657.  
  658. namespace eval prompt {}
  659. ## 
  660.  # -------------------------------------------------------------------------
  661.  # 
  662.  # "prompt::getAKey" --
  663.  # 
  664.  #  'getChar' is modified by ctrl and option, so if the user presses one
  665.  #  of them, we have to request the key again.  Also if the user pressed
  666.  #  shift and the key wasn't A-Z, then we also have to ask again.  Finally
  667.  #  if the key pressed was a non-ascii one, we have to select from a menu.
  668.  #  
  669.  #  This function is an alternative to 'dialog::getAKey'.  Hence it takes
  670.  #  the same parameters, except it ignores some of them.
  671.  #  
  672.  #  Doesn't currently deal with the 'for_menu' flag which it should.
  673.  # -------------------------------------------------------------------------
  674.  ##
  675. proc prompt::getAKey {{name ""} {keystr ""} {for_menu 1}} {
  676.     beep ; message "Press the key and modifiers"
  677.     set char [string toupper [getChar]]
  678.     set mod [getModifiers]
  679.     if {$mod & 0xd8 || ($mod & 0x22) && ![regexp {[A-Z]} $char]} {
  680.     beep; message "Please press the key again, this time without modifiers."
  681.     set char [string toupper [getChar]]
  682.     }
  683.     if {![regexp {[][=A-Z0-9`\\';,./-]} $char]} {
  684.     global keys::ascii keys::func
  685.     set ascii [text::Ascii $char]
  686.     if {$ascii > 27 && $ascii < 32} {
  687.         set char [lindex {"" "" "\x10" ""} [expr {$ascii - 27}]]
  688.     }
  689.     set i 0
  690.     foreach k ${keys::ascii} { 
  691.         if {[expr {$k == $ascii}]} { 
  692.         set char [text::Ascii [expr {$i + 97}] 1]
  693.         break
  694.         }
  695.         incr i
  696.     }
  697.     if {$i == [llength ${keys::ascii}]} {
  698.         set char [dialog::optionMenu \
  699.           "This procedure cannot isolate which key that was.  You'll have to select it manually" ${keys::func} "" 1]
  700.         set char [text::Ascii [expr {$char + 97}] 1]
  701.     }
  702.     }
  703.     set res [keys::modToMenu $mod $char]
  704.     if {!$for_menu} {
  705.     beep; message "If there is a prefix-char, hit that now (without the ctrl-key) else return."
  706.     set char [string toupper [getChar]]
  707.     if {[text::Ascii $char] == 27} { set char "e" } 
  708.     if {[regexp -nocase {[a-z]} $char]} {append res "«$char»"}
  709.     }
  710.     return $res
  711. }
  712.  
  713. ## 
  714.  # cmdKey                      = 0x01,
  715.  # shiftKey                    = 0x02,
  716.  # alphaLock                   = 0x04,
  717.  # optionKey                   = 0x08,
  718.  # controlKey                  = 0x10,
  719.  # rightShiftKey               = 0x20,
  720.  # rightOptionKey              = 0x40,
  721.  # rightControlKey             = 0x80,
  722.  ##
  723. # 'char' must be upper case, if it really is a char.
  724. proc keys::modToMenu {mod {char ""}} {
  725.     if {$char != ""} {
  726.     set t "/${char}"
  727.     } else {
  728.     set t ""
  729.     }
  730.     # cmd
  731.     if {[expr {$mod & 1}]} { append t "<O" }
  732.     # shift
  733.     if {[expr {$mod & 2 |  $mod & 32}]} { append t "<U" }
  734.     # option
  735.     if {[expr {$mod & 8 | $mod & 64}]} { append t "<I" }
  736.     # ctrl
  737.     if {[expr {$mod & 16 | $mod & 128}]} { append t "<B" }
  738.     return $t
  739. }
  740.  
  741. proc global::specialKeys {} {
  742.     global keys::specialBindings keys::specialProcs modifiedArrVars
  743.     # unbind old set
  744.     bind::fromArray keys::specialBindings keys::specialProcs 1
  745.     
  746.     if {[hook::callAll specialKeys *]} {
  747.     # rebind old set and return
  748.     bind::fromArray keys::specialBindings keys::specialProcs
  749.     return
  750.     }
  751.     
  752.     if {[catch {dialog::arrayBindings "Special keys" keys::specialBindings}]} {
  753.     # cancelled so rebind old set
  754.     bind::fromArray keys::specialBindings keys::specialProcs
  755.     return
  756.     }
  757.     # Bind new set
  758.     bind::fromArray keys::specialBindings keys::specialProcs
  759.     # perhaps do something else?
  760.     lappend modifiedArrVars keys::specialBindings
  761. }
  762.  
  763.  
  764. ## 
  765.  # -------------------------------------------------------------------------
  766.  # 
  767.  # "alpha::basicKeyBindings" --
  768.  # 
  769.  #  Bind all the obvious stuff, so cursor keys etc actually work!
  770.  # -------------------------------------------------------------------------
  771.  ##
  772. proc alpha::basicKeyBindings {} {
  773.     Bind Left  backwardChar
  774.     Bind Left <c> beginningOfLine
  775.     Bind Left <s> backwardCharSelect
  776.     Bind Left <sc> beginningLineSelect
  777.     Bind Left <z> {scrollLeftCol 15}
  778.     Bind Left <o> backwardWord
  779.     Bind Left <os> backwardWordSelect
  780.     
  781.     Bind Right  forwardChar
  782.     Bind Right <c> endOfLine
  783.     Bind Right <s> forwardCharSelect
  784.     Bind Right <sc> endLineSelect
  785.     Bind Right <z> {scrollRightCol 15}
  786.     Bind Right <o> forwardWord
  787.     Bind Right <os> forwardWordSelect
  788.     
  789.     Bind Up        previousLine
  790.     Bind Up <s>    prevLineSelect
  791.     Bind Up <sc>   beginningBufferSelect
  792.     Bind Up <z>    scrollUpLine
  793.     Bind Up <o>    pageBack
  794.     
  795.     Bind Down      nextLine
  796.     Bind Down <s>  nextLineSelect
  797.     Bind Down <sc> endBufferSelect
  798.     Bind Down <z>  scrollDownLine
  799.     Bind Down <o>  pageForward
  800.     
  801.     # Keypad definitions
  802.     Bind KPad4     backwardWord                 
  803.     Bind KPad4 <c> backwardDeleteWord 
  804.     Bind KPad6     forwardWord                 
  805.     Bind KPad6 <c> deleteWord 
  806.     Bind Clear <s> toggleNumLock
  807.     Bind Clear     insertToTop
  808.     Bind KPad- <s> nextWindow
  809.     Bind KPad+     swapWithNext
  810.     Bind KPad-     prevWindow
  811.     Bind KPad0       pageBack
  812.     Bind Enter       pageForward
  813.     Bind Kpad1     prevFunc
  814.     Bind Kpad3     nextFunc
  815.     Bind KPad.     endOfBuffer                 
  816.     Bind KPad5     exchangePointAndMark     
  817.     Bind KPad7     backwardDeleteWord         
  818.     Bind KPad8     beginningOfBuffer                 
  819.     Bind KPad9     deleteWord                 
  820.     
  821.     Bind Help       alphaHelp                     
  822.     Bind Home       beginningOfBuffer             
  823.     Bind End        endOfBuffer                 
  824.     Bind Pgup       pageBack                     
  825.     Bind Pgdn       pageForward                  
  826.     # The first two of these cause problems with dead-keys, whereas the
  827.     # latter two work ok!  Thanks Dominique
  828.     #Bind Del        deleteChar                 
  829.     #Bind 0x33        backSpace
  830.     ascii 0x08  backSpace
  831.     ascii 0x7f  deleteChar
  832. }
  833.  
  834. ## 
  835.  # -------------------------------------------------------------------------
  836.  # 
  837.  # "alpha::keyBindings" --
  838.  # 
  839.  #  Bind some 'standard' alpha key-bindings
  840.  # -------------------------------------------------------------------------
  841.  ##
  842. proc alpha::keyBindings {} {
  843.     Bind Del    <z> forwardDeleteWhitespace
  844.     Bind 0x33   <z> forwardDeleteWhitespace
  845.     Bind 0x33  <sz> forwardDeleteUntil
  846.  
  847.     Bind Up <c>    beginningOfBuffer
  848.     Bind Down <c>  endOfBuffer
  849.     Bind help <z>   {package::helpFile $mode}
  850.  
  851.     Bind 't' <z>     insertToTop        
  852.     Bind 'z' <z>     pageBack
  853.     Bind '\ ' <z>     setMark
  854.     Bind '1' <z>    execAbbrev
  855.     
  856.     # Another control prefix.
  857.     Bind 'q' <z>     prefixChar
  858.     Bind 't' <Q>    shrinkHigh
  859.     Bind 'b' <Q>    shrinkLow
  860.     Bind 'l' <Q>    shrinkLeft
  861.     Bind 'r' <Q>    shrinkRight
  862.     Bind 'c' <Q>    chooseAWindow
  863.     Bind 'h' <Q>    winhorizontally
  864.     Bind 'i' <Q>    iconify
  865.     Bind 'n' <Q>    nextWindow
  866.     Bind 'o' <Q>    bufferOtherWindow
  867.     Bind 'p' <Q>    prevWindow
  868.     Bind 's' <Q>    swapWithNext
  869.     Bind 'a' <Q>    wintiled
  870.     Bind 'v' <Q>    winvertically
  871.     Bind 'f' <Q>    shrinkFull
  872.     Bind '2' <Q>    splitWindow
  873.     
  874.     Bind '\ ' <o>    oneSpace
  875.     Bind Esc    startEscape
  876.     Bind 'f' <cz>     freeMem
  877.     Bind 'h' <z>    hiliteWord
  878.     
  879.     Bind 'm' <X>    matchingLines 
  880.     Bind 's' <ze> regIsearch
  881.     Bind 'l' <C> dividingLine
  882.     
  883.     # global bindings for CR
  884.     Bind '\r'       bind::CarriageReturn
  885.     Bind '\r' <c>  {bind::continueComment}
  886.     Bind '\r' <z>  {typeText "\r"}
  887.  
  888.     Bind   F1         bind::Completion     
  889.     Bind '\[' <zs>  normalLeftBrace
  890.     Bind '\]' <zs>  normalRightBrace
  891.     # Useful for C-like-modes
  892.     Bind '\;'      bind::electricSemi
  893.     Bind '\;' <z> "typeText {;}"
  894.     Bind 'l' <z> centerRedraw
  895.     Bind 'l' <oz> refresh
  896.     Bind 'x' <e> execute
  897. }
  898.  
  899.  
  900.  
  901.  
  902.  
  903.  
  904.